home *** CD-ROM | disk | FTP | other *** search
/ Business Shareware / Business Shareware.iso / start / database / lib194 / dates.prg < prev    next >
Encoding:
Text File  |  1993-01-05  |  43.0 KB  |  1,145 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: DATES.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1033)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are the date functions/procedures I felt were not as
  6. *--             commonly used as those left behind in PROC.PRG. See README.TXT
  7. *--             for details on the use of this library file.
  8. *-------------------------------------------------------------------------------
  9.  
  10. FUNCTION DateText3
  11. *-------------------------------------------------------------------------------
  12. *-- Programmer..: Miriam Liskin
  13. *-- Date........: 03/02/1992
  14. *-- Notes.......: Display date in format  Month, year
  15. *-- Written for.: dBASE IV, 1.1
  16. *-- Rev. History: 05/21/1991 - original function.
  17. *--               03/02/1992 - This one's Douglas P. Saine's (XRED) invention.
  18. *--               In his words: "I just removed the middle part looking for
  19. *--               the day. For the things I do, I only need the month and
  20. *--               year. (I work for a defense contracter, accuracy of dates
  21. *--               has never been of great concern. <G>)"
  22. *-- Calls.......: None
  23. *-- Called by...: Any
  24. *-- Usage.......: DateText3(<dDate>)
  25. *-- Example.....: ? DateText3(date())
  26. *-- Returns.....: July, 1991
  27. *-- Parameters..: dDate = date to be converted
  28. *-------------------------------------------------------------------------------
  29.  
  30.     parameters dDate
  31.     
  32. RETURN cmonth(dDate)+", "+str(year(dDate),4)
  33. *-- EoF: DateText3()
  34.  
  35. FUNCTION Age2
  36. *-------------------------------------------------------------------------------
  37. *-- Programmer..: Martin Leon (HMAN)
  38. *-- Date........: 04/22/1992
  39. *-- Notes.......: Returns number of full years between two dates, which is
  40. *--               age of a person born on the first date as of the second.
  41. *-- Written for.: dBASE IV, 1.1
  42. *-- Rev. History: 10/23/1991 - original function.
  43. *--               04/22/1992 -- Description modified, parameters changed by
  44. *--               Jay Parsons (CIS: 70160,340).
  45. *-- Calls.......: None
  46. *-- Called by...: Any
  47. *-- Usage.......: Age2(<d1>,<d2>)
  48. *-- Example.....: ? "Joe was "+ltrim(str(age2(dBDay,{10/16/85})))+;
  49. *--                        " on the day of ..."
  50. *-- Returns.....: Numeric value in years
  51. *-- Parameters..: d1 = first date, such as date of birth
  52. *--               d2 = second date, when age is wanted
  53. *-------------------------------------------------------------------------------
  54.  
  55.     parameters d1, d2
  56.     private nYears
  57.     
  58.     nYears = year(d2) - year(d1)
  59.     do case
  60.         case month(d1) > month(d2)
  61.             nYears = nYears - 1
  62.         case month(d1) = month(d2)
  63.             if day(d1) > day(d2)
  64.                 nYears = nYears - 1
  65.             endif
  66.     endcase
  67.  
  68. RETURN nYears
  69. *-- EoF: Age2()
  70.  
  71. FUNCTION IsLeap
  72. *-------------------------------------------------------------------------------
  73. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  74. *-- Date........: 01/13/1992
  75. *-- Notes.......: Is the year given a Leap Year? Year given must be after 1500
  76. *-- Written for.: dBASE IV, 1.1
  77. *-- Rev. History: 11/08/1991 - original function.
  78. *--               01/13/1992 -- updated to handle two digit OR four digit year.
  79. *-- Calls.......: None
  80. *-- Called by...: Any
  81. *-- Usage.......: IsLeap(<nYear>)
  82. *-- Example.....: IsLeap(91)
  83. *-- Returns.....: Logical (.t./.f.) 
  84. *-- Parameters..: nYear  = Numeric form of year -- last two digits (i.e., 91),
  85. *--                        or all four digits (i.e., 1991)
  86. *-------------------------------------------------------------------------------
  87.     
  88.     parameter nYear
  89.     private lReturn
  90.     
  91.     *-- deal with two digit year ...
  92.     if nYear < 100
  93.         nYear = nYear + 100 * int(year(date())/100)
  94.     endif
  95.     
  96.     lReturn = mod(iif(mod(nYear,100)=0,nYear/100,nYear),4)=0
  97.     
  98. RETURN lReturn
  99. *-- EoF: IsLeap()
  100.  
  101. FUNCTION Annivrsry
  102. *-------------------------------------------------------------------------------
  103. *-- Programmer..: David Love (CIS: 70153,2433) and Jay Parsons (CIS: 70160,340)
  104. *-- Date........: 11/10/1991
  105. *-- Notes.......: Checks to see if an anniversary date falls within a range of
  106. *--               dates (handy for mailings for organizations, checking to see
  107. *--               if someone's birthday falls within certain dates, etc.
  108. *-- Written for.: dBASE IV, 1.1
  109. *-- Rev. History: None
  110. *-- Calls.......: AGE2()               Function in DATES.PRG
  111. *-- Called by...: Any
  112. *-- Usage.......: Annivrsry(<dTest>,<dBegin>,<dEnd>)
  113. *-- Example.....: if Annivrsry(dBDay,{03/01/91},{03/31/91})
  114. *--                  *-- do something
  115. *--               endif
  116. *-- Returns.....: .t. if a date (dTest) falls within the period beginning at
  117. *--               dBegin or ending at dEnd, inclusive. .F. for any other
  118. *--               occurance, including invalid ranges or blank dates.
  119. *-- Parameters..: dTest  = Date being tested for ...
  120. *--               dBegin = Beginning of range
  121. *--               dEnd   = End of range
  122. *-------------------------------------------------------------------------------
  123.  
  124.     parameters dTest, dBegin, dEnd
  125.     private nYears
  126.     
  127.     nYears = 0
  128.     if dBegin <= dEnd .AND. dTest <= dEnd        && will be false if blank
  129.       nYears = age2(dTest,dEnd) - iif(dTest < dBegin,age2(dTest,dBegin-1),0)
  130.     endif
  131.  
  132. RETURN nYears > 0
  133. *-- EoF: Annivrsry()
  134.  
  135. FUNCTION AddMonths
  136. *-------------------------------------------------------------------------------
  137. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  138. *-- Date........: 11/10/1991
  139. *-- Notes.......: Finds same day as given date N months ahead. 
  140. *--               This function will return the first day of the following
  141. *--               month if there is no date in the month otherwise returned 
  142. *--               and nMonths is positive, or the last day of the month if 
  143. *--               nMonths is negative.  That is, a call with {01/31/91} 
  144. *--               (January 31, 1991) and 1 would yield March 1, there being 
  145. *--               no February 31.
  146. *--                 Do not use this function successively to find first the
  147. *--               date one month ahead, then the date one month beyond that.  
  148. *--               Instead, to find the date two months ahead from the original 
  149. *--               date, call this function with the original date and 
  150. *--               nMonths = 2.  Otherwise, in the example, you'll get April 1 
  151. *--               the second time rather than the correct March 31.
  152. *-- Written for.: dBASE IV, 1.1
  153. *-- Rev. History: None
  154. *-- Calls.......: None
  155. *-- Called by...: Any
  156. *-- Usage.......: AddMonths(<dDate>,<nMonths>)
  157. *-- Example.....: ?AddMonths({01/01/91},1)
  158. *-- Returns.....: Date
  159. *-- Parameters..: dDate   = Date being tested for ...
  160. *--               dMonths = Number of months "ahead"
  161. *-------------------------------------------------------------------------------
  162.     
  163.     parameters dDate, nMonths
  164.     private dNew, dTest,dReturn
  165.     
  166.     dNew = dDate - day(dDate)+ 15 + 30.436875 * nMonths  && middle of month
  167.     dTest = dNew - day(dNew) + day(dDate)
  168.     dReturn = iif(month(dTest) = month(dNew),dTest, ;
  169.            dTest - day(dTest) + iif(nMonths > 0, 1, 0))
  170.  
  171. RETURN dReturn
  172. *-- EoF: AddMonths()
  173.  
  174. FUNCTION AddYears
  175. *-------------------------------------------------------------------------------
  176. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  177. *-- Date........: 11/14/1991
  178. *-- Notes.......: Finds same day as given date N years ahead. 
  179. *--               Using this function dBASE IV will take care of converting 
  180. *--               February 29 to March 1 if moving from a leap to a non-leap
  181. *--               year.  However, neither may be used backwards (negative 
  182. *--               value of nYears) since the date a year before February 29,
  183. *--               1992 will be returned as March 1, 1991, not February 28, 1991.
  184. *--               If you must move back, either check explicitly for February 29
  185. *--               as the original date or add code as in the addmonths()
  186. *--               function to test for the date returned being of a different
  187. *--               month than the original and, if it is, to subtract its day().
  188. *-- Written for.: dBASE IV, 1.1
  189. *-- Rev. History: 11/10/1991 - original function.
  190. *--               11/14/1991 - Ken Mayer - expanded out to make it easier
  191. *--                          to read, and see what's happening.
  192. *-- Calls.......: None
  193. *-- Called by...: Any
  194. *-- Usage.......: AddYears(<dDate>,<nYears>)
  195. *-- Example.....: ?AddYears({01/01/91},1)
  196. *-- Returns.....: Date
  197. *-- Parameters..: dDate  = Date being tested for ...
  198. *--               dYears = Number of Years "ahead"
  199. *-------------------------------------------------------------------------------
  200.     
  201.     parameters dDate, nYears
  202.     private cYear,cMonth,cDay,dReturn
  203.     
  204.     cYear = str(year(dDate) + nYears)
  205.     cMonth = right(str(month(dDate) + 100),2)
  206.     cDay = right(str(day(dDate) + 100),2)
  207.     dReturn = ctod(cMonth+"/"+cDay+"/"+cYear)
  208.         
  209. RETURN dReturn
  210. *-- EoF: AddYears()
  211.  
  212. FUNCTION DoY
  213. *-------------------------------------------------------------------------------
  214. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  215. *-- Date........: 11/14/1991
  216. *-- Notes.......: Returns the day of the year of a date (from beginning of the
  217. *--               year).
  218. *-- Written for.: dBASE IV, 1.1
  219. *-- Rev. History: 11/10/1991 - original function.
  220. *--               11/14/1991 - Ken Mayer - expanded for readability ...
  221. *-- Calls.......: None
  222. *-- Called by...: Any
  223. *-- Usage.......: DoY(<dDate>)
  224. *-- Example.....: ?DoY({01/01/91})
  225. *-- Returns.....: Numeric value of day of year
  226. *-- Parameters..: dDate  = Date being tested for ...
  227. *-------------------------------------------------------------------------------
  228.  
  229.     parameters dDate
  230.     private cYear,dStart,nReturn
  231.     
  232.     cYear = right(str(year(dDate)),2)
  233.     dStart = ctod("01/01/"+cYear)
  234.     nReturn = dDate+1 - dStart
  235.     
  236. RETURN nReturn
  237. *-- EoF: DoY()
  238.  
  239. FUNCTION WeekNo
  240. *-------------------------------------------------------------------------------
  241. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  242. *-- Date........: 11/14/1991
  243. *-- Notes.......: Returns the week number of the year of a date (from beginning 
  244. *--               of the year).
  245. *--               To use this function but start the week on a different day,
  246. *--               change the 1 in the second-to-last line, the dow() of Sunday, 
  247. *--               to the dow() of the day that should start each week, 2 for 
  248. *--               Monday through 7 for Saturday.
  249. *-- Written for.: dBASE IV, 1.1
  250. *-- Rev. History: 11/10/1991 - original function.
  251. *--               11/14/91 - Ken Mayer - expanded for readability ...
  252. *-- Calls.......: None
  253. *-- Called by...: Any
  254. *-- Usage.......: WeekNo(<dDate>)
  255. *-- Example.....: ?WeekNo({01/01/91})
  256. *-- Returns.....: Numeric value of week number
  257. *-- Parameters..: dDate  = Date being tested for ...
  258. *-------------------------------------------------------------------------------
  259.     
  260.     parameters dDate
  261.     private dBaseDate,nReturn
  262.     
  263.     dBaseDate = dDate - doy(dDate)
  264.     dBaseDate = dBaseDate - mod(dow(dBaseDate - 1), 7)
  265.     nReturn = int((dDate - dBaseDate) / 7)
  266.  
  267. RETURN nReturn
  268. *-- EoF: WeekNo()
  269.  
  270. FUNCTION Holiday
  271. *-------------------------------------------------------------------------------
  272. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  273. *-- Date........: 04/22/1992
  274. *-- Notes.......: Returns the date of a specific "floating" holiday (using 
  275. *--               chart below) for current year. 
  276. *--               Name                 Code
  277. *--               President's Day      P
  278. *--               Daylight saving time D
  279. *--               Memorial Day         M
  280. *--               Labor Day            L
  281. *--               Columbus Day         C
  282. *--               Resume Standard time S
  283. *--               Election Day         E
  284. *--               Thanksgiving         T
  285. *--               Advent (1st Sunday)  A
  286. *-- Written for.: dBASE IV, 1.1
  287. *-- Rev. History: 11/01/1991 - original function.
  288. *--               11/15/1991 - Ken Mayer - takes a code and year -- I basically
  289. *--               simplified the use of the function.
  290. *--               04/22/1992 - Jay Parsons - added 'D' and 'S' options
  291. *--               (daylight saving time and return to standard)
  292. *-- Calls.......: None
  293. *-- Called by...: Any
  294. *-- Usage.......: Holiday(<nYear>,"<cCode>")
  295. *-- Example.....: ? Holiday(92,"P")   && date of President's day, 1992
  296. *-- Returns.....: Date of specified holiday ...
  297. *-- Parameters..: nYear = Year you need the holiday date for ...
  298. *--               cCode = one of the codes above for specific holiday
  299. *-------------------------------------------------------------------------------
  300.  
  301.     parameters nYear,cCode
  302.     private dBaseDate,cCode,cYear,nDoW,cFirst,dReturn
  303.     
  304.     cCode = upper(cCode)
  305.     cYear = ltrim(str(nYear))
  306.     do case
  307.                 case cCode = "P"    && President's day (3rd Mon of Feb)
  308.             cFirst = "02/15/"
  309.             nDoW   = 2
  310.         case cCode = "D"    && Daylight time U.S. (1st Sun of April)
  311.             cFirst = "04/01/"
  312.             nDoW   = 1
  313.                 case cCode = "M"    && Memorial day  (last Mon of May)
  314.                         cFirst = "05/25/"
  315.             nDoW   = 2
  316.         case cCode = "L"    && Labor day  (1st Mon of Sep)
  317.                         cFirst = "09/01/"
  318.             nDoW   = 2
  319.         case cCode = "C"    && Columbus Day  (2nd Mon of Oct)
  320.                         cFirst = "10/08/"
  321.             nDoW   = 2
  322.                 case cCode = "S"    && Standard Time U.S. (Last Sun of Oct)
  323.             cFirst = "10/25/"
  324.             nDoW = 1
  325.         case cCode = "E"    && Election Day  (1st Tues of Nov not Nov 1)
  326.                         cFirst = "11/02/"
  327.             nDoW   = 3
  328.         case cCode = "T"    && Thanksgiving (fourth Thursday of Nov)
  329.                         cFirst = "11/22/"
  330.             nDoW   = 5
  331.         case cCode = "A"    && 1st Sun of Advent (Sunday closest Nov 30)
  332.                         cFirst = "11/27/"
  333.             nDoW   = 1
  334.         otherwise
  335.             return {}        && if not one of above, return blank date ...
  336.     endcase
  337.     dFirst = ctod(cFirst + cYear)
  338.         dBaseDate = dFirst + 7 - nDow
  339.         dReturn = dBaseDate - dow( dBaseDate ) + nDow    && dow( dBaseDate )
  340.     
  341. RETURN dReturn
  342. *-- EoF: Holiday()
  343.  
  344. FUNCTION EasterDay
  345. *-------------------------------------------------------------------------------
  346. *-- Programmer..: Jay Parsons (USSBBS, CIS 70160,340)
  347. *-- Date........: 12/03/1992
  348. *-- Notes.......: Returns date of Easter for given year after 1582.
  349. *--               This gives the date of Easter as celebrated by Western
  350. *--               churches.  The algorithm is from Example 1.3.2.14 of
  351. *--               Volume I of "The Art of Computer Programming", 2nd
  352. *--               Edition, Addison-Wesley, Reading, MA, 1973, by Donald
  353. *--               Knuth, who attributes it to Aloysius Lilius of Naples
  354. *--               and Christopher Clavius of Germany, both floruit 1582.
  355. *-- Written for.: dBASE IV, 1.1
  356. *-- Rev. History: 11/18/1991 - original function.
  357. *--               04/22/1992 - Jay Parsons - Notes expanded.
  358. *--               11/20/1992 - David Love - Added the private variable lYear
  359. *--               12/03/1992 - Jay Parsons - renamed lYear to nYr, dPascMoon
  360. *-- Calls.......: None
  361. *-- Called by...: Any
  362. *-- Usage.......: EasterDay(<Year>)
  363. *-- Example.....: EasterDay(91)
  364. *-- Returns.....: Date (in dBASE date format) of Easter
  365. *-- Parameters..: nYear  =  Numeric form of year - YYYY or YY format
  366. *-------------------------------------------------------------------------------
  367.     
  368.     parameters nYear
  369.     private nYr,nGolden,nCentury,nNoLeap,nMoonOrbit,nEPact,dPascMoon,dReturn
  370.     
  371.     *-- deal with two digit year ...
  372.     nYr = nYear
  373.     if nYr < 100
  374.         nYr = nYr + 100 * int(year(date())/100)
  375.     endif
  376.     
  377.     nGolden     = 1+mod(nYr,19)
  378.     nCentury    = floor(nYr/100)+1
  379.     nNoLeap     = floor(3*nCentury/4)-12
  380.     nMoonOrbit  = floor((8*nCentury+5)/25)-5
  381.     nEPact      = mod(11*nGolden+nMoonOrbit-nNoLeap+20,30)
  382.     nEPact      = nEPact+iif(nEPact=24.or.(nEPact=25.and.nGolden>11),1,0)
  383.     dPascMoon   = ctod("03/21/"+str(nYr)+mod(53-nEPact,30))
  384.     dReturn     = dPascMoon+8-dow(dPascMoon)
  385.  
  386. RETURN dReturn
  387. *-- EoF: EasterDay()
  388.  
  389. FUNCTION nDoW
  390. *-------------------------------------------------------------------------------
  391. *-- Programmer..: Jay Parsons (CIS: 70160,340) 
  392. *-- Date........: 04/22/1992
  393. *-- Notes.......: Numeric Day of Week -- returns the numeric value of the
  394. *--               day of week for use by some of the other date functions
  395. *--               below.
  396. *-- Written for.: dBASE IV, 1.1
  397. *-- Rev. History: 02/25/1992 - original function.
  398. *--               04/22/1992 - Jay Parsons - modified example/descriptions,
  399. *--               added ltrim() of argument.
  400. *-- Calls.......: None
  401. *-- Called by...: None
  402. *-- Usage.......: nDoW(<cDay>)
  403. *-- Example.....: nDay = nDoW("Tues")
  404. *-- Returns.....: Numeric dow value of day of week given
  405. *-- Parameters..: cDay  -- Character memvar containing "day" of week ('MONDAY',
  406. *--                        etc ...)
  407. *-------------------------------------------------------------------------------
  408.  
  409.     parameter cDay
  410.     
  411. RETURN at(upper(left(ltrim(cDay),3)),"   SUN MON TUE WED THU FRI SAT")/4
  412. *-- nDoW()
  413.  
  414. FUNCTION FWDoM
  415. *-------------------------------------------------------------------------------
  416. *-- Programmer..: Jay Parsons (CIS: 70160,340) 
  417. *-- Date........: 02/25/1992
  418. *-- Notes.......: First Working Day of the Month -- originally I used Dan
  419. *--               Madoni's stuff from Technotes, but Jay came along and pointed
  420. *--               out an easier way to do this. SO, here we have a shorter,
  421. *--               faster, FWDoM function. This returns the first WORKING
  422. *--               day of the month.
  423. *-- Written for.: dBASE IV, 1.1
  424. *-- Rev. History: None
  425. *-- Calls.......: None
  426. *-- Called by...: Any
  427. *-- Usage.......: FWDoM(<dDate>)
  428. *-- Example.....: ? CDoW( FWDoM(DATE()) ) (character day of week ...)
  429. *-- Returns.....: dBASE Date
  430. *-- Parameters..: dDate  -- date to work from ...
  431. *-------------------------------------------------------------------------------
  432.  
  433.     parameters dDate
  434.     private dReturn, nDay
  435.     
  436.     dReturn = dDate - day(dDate) + 1
  437.     nDay = DoW(dReturn)
  438.     
  439. RETURN dReturn + iif(nDay=7,2,iif(nDow=1,1,0))
  440. *-- EoF: FWDoM()
  441.  
  442. FUNCTION LWDoM
  443. *-------------------------------------------------------------------------------
  444. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  445. *-- Date........: 02/25/1992
  446. *-- Notes.......: Last Working Day of the Month -- function from Jay (new
  447. *--               version like FWDoM) to return the last working day of the
  448. *--               month. Give a date, the function returns the last WORKING day 
  449. *--               of the month. This has a companion function, giving the 
  450. *--               FIRST working day (see above).
  451. *-- Written for.: dBASE IV, 1.1
  452. *-- Rev. History: None
  453. *-- Calls.......: LDOM()               Function in DATES.PRG
  454. *-- Called by...: Any
  455. *-- Usage.......: LWDoM(<dDate>)
  456. *-- Example.....: ? LWDoM(DATE())
  457. *-- Returns.....: dBASE Date
  458. *-- Parameters..: dDate  -- date to work from ...
  459. *-------------------------------------------------------------------------------
  460.  
  461.     parameters dDate
  462.     private dReturn, nDay
  463.     
  464.     dReturn = ldom(dDate)
  465.     nDay = DoW(dReturn)
  466.  
  467. RETURN dReturn - iif(nDay=7,1,iif(nDay=1,2,0))
  468. *-- EoF: LWDoM()
  469.  
  470. FUNCTION FDoD
  471. *-------------------------------------------------------------------------------
  472. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  473. *-- Date........: 02/25/1992
  474. *-- Notes.......: First Day of Date. This function works to give the first
  475. *--               date in a given month (using a date) that a specific day
  476. *--               of the week occurs (i.e., first Monday of the month).
  477. *--               It returns a blank date if the day of week doesn't match, 
  478. *--               but is not case sensitive. New, slimmer, sleeker version
  479. *--               by Jay ...
  480. *-- Written for.: dBASE IV, 1.1
  481. *-- Rev. History: None
  482. *-- Calls.......: NDOW()               Function in DATES.PRG
  483. *-- Called by...: Any
  484. *-- Usage.......: FDoD(<dDate>,"<cDay>")
  485. *-- Example.....: ? FDoD(DATE(),"Tuesday")
  486. *-- Returns.....: dBASE Date
  487. *-- Parameters..: dDate  -- date to work from ...
  488. *--               cDay   -- Day of week to look for ...
  489. *-------------------------------------------------------------------------------
  490.  
  491.     parameters dDate, cDay
  492.     private dReturn, nDay
  493.     
  494.     nDay = nDoW(cDay)
  495.     dReturn = dDate - day(dDate) + 1
  496.     
  497. RETURN dReturn + mod(nDay+7 - DoW(dReturn),7)
  498. *-- EoF: FDoD()
  499.  
  500. FUNCTION LDoD
  501. *-------------------------------------------------------------------------------
  502. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  503. *-- Date........: 02/25/1992
  504. *-- Notes.......: Last Day of Date. This function works to give the last
  505. *--               date in a given month (using a date) that a specific day
  506. *--               of the week occurs (i.e., last Monday of the month).
  507. *--               It returns a blank date if the day of week doesn't match, 
  508. *--               but is not case sensitive. New version as FDoD() ...
  509. *-- Written for.: dBASE IV, 1.1
  510. *-- Rev. History: None
  511. *-- Calls.......: LDOM()               Function in DATES.PRG
  512. *--               NDOW()               Function in DATES.PRG
  513. *-- Called by...: Any
  514. *-- Usage.......: LDoD(<dDate>,"<cDay>")
  515. *-- Example.....: ? LDoD(DATE(),"Tuesday")
  516. *-- Returns.....: dBASE Date
  517. *-- Parameters..: dDate  -- date to work from ...
  518. *--               cDay   -- Day of week to look for ...
  519. *-------------------------------------------------------------------------------
  520.  
  521.     parameters dDate, cDay
  522.     private dReturn
  523.     
  524.     nDay = nDoW(cDay)
  525.     dReturn = ldom(dDate)
  526.     
  527. RETURN dReturn - mod(dow(dReturn) + 7 - nDay,7)
  528. *-- EoF: LDoD()
  529.  
  530. FUNCTION LDoM
  531. *-------------------------------------------------------------------------------
  532. *-- Programmer..: Ken Chan (HazMatZak)
  533. *-- Date........: 02/26/1992
  534. *-- Notes.......: Last Day of Month -- Zak wrote this one up as a MUCH shorter
  535. *--               and more straightforward version of the one I did. >sigh<.
  536. *--               This function returns the date of the last day of the month.
  537. *-- Written for.: dBASE IV, 1.1
  538. *-- Rev. History: None
  539. *-- Calls.......: None
  540. *-- Called by...: Any
  541. *-- Usage.......: LDoM(<dDate>)
  542. *-- Example.....: ? LDoM(DATE())
  543. *-- Returns.....: dBASE Date
  544. *-- Parameters..: dDate  -- date to work from ...
  545. *-------------------------------------------------------------------------------
  546.  
  547.     parameter dDate
  548.     private dNxtMonth
  549.     
  550.     dNxtMonth = dDate - day(dDate) + 45 && middle of next month
  551.     
  552. RETURN dNxtMonth - day(dNxtMonth)
  553. *-- EoF: LDoM()
  554.  
  555. FUNCTION NumDoD
  556. *-------------------------------------------------------------------------------
  557. *-- Programmer..: Ken Mayer (CIS: 71333,1033)
  558. *-- Date........: 02/24/1992
  559. *-- Notes.......: This function will return the x daytype of a month.
  560. *--               Example: what if you need the third Monday of the month?
  561. *-                Send to this function a date (any date) of the month,
  562. *--               the number you need (first, second...) and the day you
  563. *--               need. The function is not case specific.
  564. *-- Written for.: dBASE IV, 1.1
  565. *-- Rev. History: None
  566. *-- Calls.......: FDOD()               Function in DATES.PRG
  567. *--               NDOW()               Function in DATES.PRG
  568. *-- Called by...: Any
  569. *-- Usage.......: NumDoD(<dDate>,<nDay>,<cDay>)
  570. *-- Example.....: ?NumDoD({02/03/92},3,"Monday")
  571. *-- Returns.....: Date
  572. *-- Parameters..: dDate  =  Any date of the month (and year) needed
  573. *--               nDay   =  Number of day you need (i.e., third cDay of month)
  574. *--               cDay   =  Character value of day (Monday, Tuesday, etc.)
  575. *-------------------------------------------------------------------------------
  576.  
  577.     parameter dDate, nDay, cDay
  578.     private dReturn
  579.     
  580.     dReturn = FDoD(dDate,cDay)  && get the first day of this type of the month
  581.     if nDay > 1                 && if it's greater than one, add 7 (1 week) for
  582.                                 && required # ...
  583.         dReturn = dReturn + ((nDay-1)*7)
  584.     endif
  585.     
  586. RETURN dReturn
  587. *-- EoF: NumDoD()
  588.  
  589. FUNCTION WDiF
  590. *-------------------------------------------------------------------------------
  591. *-- Programmer..: Martin Leon (HMAN)
  592. *-- Date........: 12/12/1991
  593. *-- Notes.......: This UDF is designed to return the first Working Day In the
  594. *--               Future of a specific date, based on a # of days. For example,
  595. *--               to return the first working day, 10 days from the current
  596. *--               date, you can pass the parameters of DATE() and 10. If the
  597. *--               date 10 days from today is a working day, that date is
  598. *--               returned, otherwise, the function returns the next closest
  599. *--               working day. You may, if you wish, use a database to
  600. *--               store holidays. If you do, the database must be laid out
  601. *--               with the following structure:
  602. *--                 HOLIDAYS.DBF
  603. *--                 Field name  Field type  MDX?
  604. *--                 HOLIDATE      Date       Y
  605. *--               Once the UDF has been run, the database is left open in 
  606. *--               whatever work area it was opened.  If another database was 
  607. *--               in use at the time of calling the UDF, it becomes the active
  608. *--               database after the UDF is done. The reason for leaving the 
  609. *--               database open is that this speeds up the process when you 
  610. *--               call on the UDF several times in a row.
  611. *--               To ensure that holidays are working properly, there are
  612. *--               3 assumptions made by this function, and all must be true.
  613. *--               These are: 1) WDIF() assumes that your holidays database
  614. *--               has an index tag on the HOLIDATE field, 2) there are no
  615. *--               duplicate entries, and 3) none of the holidays in the data-
  616. *--               base fall on a weekend date. A simple method for insuring
  617. *--               the last is:
  618. *--                 USE Holidays
  619. *--                 DELETE FOR DOW( Holidate ) = 7 .or. DOW( Holidate ) = 1
  620. *--                 PACK
  621. *--               If you do not have a Holidays database, this function will 
  622. *--               work fine ...
  623. *-- Written for.: dBASE IV, 1.1
  624. *-- Rev. History: None
  625. *-- Calls.......: None
  626. *-- Called by...: Any
  627. *-- Usage.......: WDIF(<dStart>,<nDays>)
  628. *-- Example.....: ?WDiF(date(),10)
  629. *-- Returns.....: dBASE date
  630. *-- Parameters..: dStart  =  Date to start counting from
  631. *--               nDays   =  Number of working days in the future ...
  632. *-------------------------------------------------------------------------------
  633.  
  634.     parameter dStart, nWDays
  635.     private nweeks, n, nXtraDays, nHDays, dReturn, cNear, cAlias, dTemp
  636.     
  637.     store 0 to nweeks, n, nHDays, nXtraDays
  638.     store {} to dReturn, dTemp
  639.     store "" to cNear, cAlias
  640.     cNear = set("NEAR")
  641.     
  642.     if nWDays = 0
  643.        RETURN 0
  644.     endif
  645.     
  646.     if type("dStart") + type("nWDays") # "DN"
  647.        RETURN -1
  648.     endif
  649.     
  650.     *-- Rough guestimate of future date within a week
  651.     nweeks = int( nWDays / 5 )
  652.     dReturn = dStart + (nweeks * 7)
  653.     
  654.     *-- Left over number of days from integer division above
  655.     nXtraDays = mod( nWDays, 5 )
  656.     
  657.     *-- Check to see if Holidays database is already in use.  This is
  658.     *-- done so that we don't have to close and open the database for
  659.     *-- every call to this UDF. The first call opens it and subsequent
  660.     *-- calls select it as needed.
  661.     
  662.     *-- Check all work areas for holidays database, starting with work
  663.     *-- area 10 since this is most likely where it was opened the
  664.     *-- first time.
  665.     n = 10
  666.     do while .not. "HOLIDAYS" $ alias( n )
  667.        n = n - 1
  668.        if n = 0
  669.           exit
  670.        endif
  671.     enddo
  672.     *-- If it is open, store current alias name and select holidays
  673.     *-- database.
  674.     if n # 0
  675.        cAlias = alias()
  676.        select (alias(n))
  677.     else
  678.        *-- If it isn't the currently selected database,
  679.        *-- make sure it exists and use it and select it.
  680.        if file( "HOLIDAYS.DBF" )
  681.           cAlias = alias()
  682.           use Holidays order Holidate in select()
  683.           select Holidays
  684.        endif
  685.     endif
  686.     *-- If it's active now ...
  687.     if alias() = "HOLIDAYS"
  688.        *-- make sure it's in Holidate order, and ...
  689.        if order() # "HOLIDATE"
  690.           set order to Holidate
  691.        endif
  692.        set near on
  693.        *-- count all records in holiday database that fall within the
  694.        *-- range of the starting date and the rough guestimate date.
  695.        seek dStart
  696.        *-- don't count starting day if it's in Holidays database.
  697.        if dStart = Holidate
  698.           skip
  699.        endif
  700.        scan while dReturn >= Holidate 
  701.           nHDays = nHDays + 1
  702.        endscan
  703.        set near off
  704.     endif
  705.     
  706.     *-- Add holidays to "left over" days from original guestimate
  707.     nXtraDays = nXtraDays + nHDays
  708.     
  709.     *-- Add extra days one day at a time to the original guestimate,
  710.     *-- skipping over holidays and weekends.
  711.     
  712.     do while nXtraDays > 0
  713.        dReturn = dReturn + 1
  714.        if alias() = "HOLIDAYS"
  715.           if seek(dReturn)
  716.              loop
  717.           endif
  718.        endif
  719.        if dow( dReturn ) = 7 .or. dow( dReturn ) = 1
  720.           loop
  721.        endif
  722.        nXtraDays = nXtraDays - 1
  723.     enddo
  724.     
  725.     *-- If return date falls on Saturday or Sunday, "re-wind" to Friday.
  726.     dReturn = dReturn - ;
  727.        iif( dow( dReturn ) = 7, 1, iif( dow(dReturn) = 1, 2, 0 ))
  728.     
  729.     *-- If another database was origally in use, make it the active
  730.     *-- database again.
  731.     if "" # cAlias
  732.        select (cAlias)
  733.     endif
  734.     *-- set NEAR back to what it was orginally.
  735.     set near &cNear
  736.  
  737. RETURN dReturn
  738. *-- EoF: WDiF()
  739.  
  740. FUNCTION StoD
  741. *-------------------------------------------------------------------------------
  742. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  743. *-- Date........: 11/10/91
  744. *-- Notes.......: Convert string YYYYMMDD or YYMMDD to a date regardless of
  745. *--               SET DATE. 
  746. *-- Written for.: dBASE IV, 1.1
  747. *-- Rev. History: None
  748. *-- Calls.......: None
  749. *-- Called by...: Any
  750. *-- Usage.......: StoD("<cString>")
  751. *-- Example.....: ?StoD("19910101")
  752. *-- Returns.....: Date
  753. *-- Parameters..: <cString> = Date string you wish converted to "normal" dBASE
  754. *--                           date. Must be in either YYYYMMDD or YYMMDD format.
  755. *-------------------------------------------------------------------------------
  756.  
  757.     parameters cString
  758.     private dTest, cMonth, cDay, cYear, dReturn
  759.     
  760.     dTest = ctod("01/02/03")
  761.     if len(cString) < 8
  762.         cString = left(str(year(date()),4),2) + cString
  763.     endif
  764.     cYear  = left(cString, 4)
  765.     cMonth = substr(cString, 5, 2)
  766.     cDay   = right(cString, 2)
  767.     do case
  768.         case month(dTest) = 1
  769.             dReturn = ctod(cMonth + "/" + cDay + "/" + cYear)
  770.         case day(dTest) = 1
  771.             dReturn = ctod(cDay + "/" + cMonth + "/" + cYear)
  772.         otherwise
  773.             dReturn = ctod(cYear + "/" + cMonth + "/" + cDay)
  774.     endcase
  775.  
  776. RETURN dReturn
  777. *-- EoF: StoD()
  778.  
  779. FUNCTION Quarter
  780. *-------------------------------------------------------------------------------
  781. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  782. *-- Date........: 02/03/1992
  783. *-- Notes.......: Returns the quarter of the year of a specific date ...
  784. *-- Written for.: dBASE IV, 1.1
  785. *-- Rev. History: None
  786. *-- Calls.......: None
  787. *-- Called by...: Any
  788. *-- Usage.......: Quarter(<dDate>)
  789. *-- Example.....: ?Quarter({05/25/1992})
  790. *-- Returns.....: Numeric (integer) value from 1 to 4 (or 0 on error ...)
  791. *-- Parameters..: dDate = date to be checked
  792. *-------------------------------------------------------------------------------
  793.  
  794.     Parameter dDate
  795.  
  796. RETURN iif(type("dDate")="D",ceiling(month(dDate)/3),0)
  797. *-- EoF: Quarter()
  798.  
  799. FUNCTION Dat2Jul
  800. *-------------------------------------------------------------------------------
  801. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  802. *-- Date........: 03/01/92
  803. *-- Notes.......: Converts dBASE date to Julian # of days (from January 1,
  804. *--               3713 B.C.)
  805. *-- Rev. History: None
  806. *-- Written for.: dBASE IV
  807. *-- Rev. History: None
  808. *-- Calls.......: None
  809. *-- Called by...: Any
  810. *-- Usage.......: Dat2Jul("<dDate>")
  811. *-- Example.....: ?Dat2Jul(date())
  812. *-- Returns.....: Numeric
  813. *-- Parameters..: dDate = Date to convert to Julian ...
  814. *-------------------------------------------------------------------------------
  815.  
  816.     PARAMETERS dDate
  817.     
  818. RETURN 2415386 + dDate - ctod( "01/01/01" )
  819. *-- EoF: Dat2Jul()
  820.  
  821. FUNCTION Jul2Dat
  822. *-------------------------------------------------------------------------------
  823. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  824. *-- Date........: 03/01/92
  825. *-- Notes.......: Converts Julian # of days to dBASE Date
  826. *-- Rev. History: None
  827. *-- Written for.: dBASE IV
  828. *-- Rev. History: None
  829. *-- Calls.......: None
  830. *-- Called by...: Any
  831. *-- Usage.......: Jul2Dat(nJulian)
  832. *-- Example.....: ?Jul2Dat(2448691)
  833. *-- Returns.....: Date
  834. *-- Parameters..: nJulian = Julian date to convert to dBase Date
  835. *-------------------------------------------------------------------------------
  836.  
  837.     parameters nJulian
  838.     
  839. RETURN ctod( "01/01/01" ) + (nJulian - 2415386)
  840. *-- EoF: Jul2Dat()
  841.  
  842. FUNCTION DateSet
  843. *-------------------------------------------------------------------------------
  844. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  845. *-- Date........: 03/01/92
  846. *-- Notes.......: Returns string giving name of current DATE format
  847. *--               This is not needed in Version 1.5, in which set("DATE")
  848. *--               returns the format.  Unlike that function in 1.5, this
  849. *--               one cannot distinguish between date formats set with
  850. *--               different terms that amount to the same thing:
  851. *--                     DMY = BRITISH = FRENCH
  852. *--                     MDY = AMERICAN
  853. *--                     YMD = JAPAN
  854. *--               If your users will be using one of these formats and
  855. *--               are sensitive about the name, substitute the one they
  856. *--               want for the equivalent in this function.
  857. *-- Rev. History: None
  858. *-- Written for.: dBASE IV, versions below 1.5
  859. *-- Rev. History: None
  860. *-- Calls.......: None
  861. *-- Called by...: Any
  862. *-- Usage.......: DateSet()
  863. *-- Example.....: ?DateSet()
  864. *-- Returns.....: Character
  865. *-- Parameters..: None
  866. *-------------------------------------------------------------------------------
  867.  
  868.     private cCent, cTestdate, cDelimiter
  869.     cCent = set( "CENTURY" )
  870.     set century off
  871.     cTestdate = ctod( "01/02/03" )
  872.     cDelimiter = substr( dtoc( cTestdate ), 3, 1 )
  873.     set century &cCent
  874.     do case
  875.       case month( cTestdate ) = 1
  876.         RETURN iif( cDelimiter = "-", "USA", "MDY" )
  877.       case day( cTestdate ) = 1
  878.         RETURN iif( cDelimiter = "/", "DMY", ;
  879.           iif( cDelimiter = ".", "GERMAN", "ITALIAN" ) )
  880.       otherwise
  881.         RETURN iif( cDelimiter = ".", "ANSI", "YMD" )
  882.     endcase
  883.     
  884. *-- EoF: DateSet()
  885.  
  886. FUNCTION FrstNxtMth
  887. *-------------------------------------------------------------------------------
  888. *-- Programmer..: Todd Barry (TODDBARRY)
  889. *-- Date........: 04/04/1992
  890. *-- Notes.......: Returns first day of next month
  891. *-- Written for.: dBASE IV, 1.1
  892. *-- Rev. History: None
  893. *-- Calls.......: None
  894. *-- Called by...: Any
  895. *-- Usage.......: FrstNxtMth(<dDate>)
  896. *-- Example.....: FrstNxtMth( dDate )
  897. *-- Returns.....: dBASE Date
  898. *-- Parameters..: dDate  -- date to work from ...
  899. *-------------------------------------------------------------------------------
  900.     
  901.     parameters dDate
  902.     private nYear, nMonth
  903.     
  904.     nYear  = year( dDate )
  905.     nMonth = month( dDate )
  906.  
  907.     * return same if blank
  908.     if nYear = 0
  909.         RETURN dDate
  910.     endif
  911.  
  912.     if nMonth < 12
  913.         * all months except December
  914.         nMonth = nMonth + 1
  915.     else
  916.         * December
  917.         nMonth = 1
  918.         nYear  = nYear + 1
  919.     endif
  920.  
  921. RETURN ctod( str( nMonth ) + "/" + "01" + "/" + str( nYear ) )
  922. *-- EoF: FrstNxtMth()
  923.  
  924. FUNCTION FDoM
  925. *-------------------------------------------------------------------------------
  926. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  927. *-- Date........: 01/05/1993
  928. *-- Notes.......: First Day of Month 
  929. *-- Written for.: dBASE IV, 1.5
  930. *-- Rev. History: None
  931. *-- Calls.......: None
  932. *-- Called by...: Any
  933. *-- Usage.......: FDoM(<dArg>)
  934. *-- Example.....: ?FDOM(date())
  935. *-- Returns.....: Date
  936. *-- Parameters..: dArg = a Date argument -- function returns first day of the
  937. *--                      month of this date.
  938. *-------------------------------------------------------------------------------
  939.  
  940.   parameter dArg
  941.  
  942. RETURN dArg - day( dArg ) + 1
  943. *-- EoF: FDoM()
  944.  
  945. FUNCTION FDoY
  946. *-------------------------------------------------------------------------------
  947. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  948. *-- Date........: 01/05/1993
  949. *-- Notes.......: Returns the January 1 of the year of the date argument passed
  950. *--               to it.
  951. *-- Written for.: dBASE IV, 1.5
  952. *-- Rev. History: None
  953. *-- Calls.......: None
  954. *-- Called by...: Any
  955. *-- Usage.......: FDoY(<dArg>))
  956. *-- Example.....: FDoY(DATE())
  957. *-- Returns.....: January 1 of the year in dArg
  958. *-- Parameters..: dArg = date data
  959. *-------------------------------------------------------------------------------
  960.  
  961.   parameter dArg
  962.   private dJan
  963.   dJan = dArg - day( dArg ) + 1 - 28 * ( month( dArg ) - 1 )
  964.  
  965. RETURN dJan - day( dJan ) + 1
  966. *-- EoF: FDoY()
  967.  
  968. FUNCTION LDoY
  969. *-------------------------------------------------------------------------------
  970. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  971. *-- Date........: 01/05/1993
  972. *-- Notes.......: Returns December 31 of year in date argument passed to 
  973. *--               function.
  974. *-- Written for.: dBASE IV, 1.5
  975. *-- Rev. History: None
  976. *-- Calls.......: LDoM()               Function in DATES.PRG
  977. *-- Called by...: Any
  978. *-- Usage.......: LDoY(<dArg>)
  979. *-- Example.....: ?LDoY(Date())
  980. *-- Returns.....: Last Day of Year
  981. *-- Parameters..: dArg = Date 
  982. *-------------------------------------------------------------------------------
  983.  
  984.   parameter dArg
  985.   private dDec
  986.   dDec = dArg - day( dArg ) + 28 * ( 13 - month( dArg ))
  987.  
  988. RETURN LDoM( dDec )
  989. *-- EoF: LDoY()
  990.  
  991. FUNCTION QDate
  992. *-------------------------------------------------------------------------------
  993. *-- Programmer..: Kenneth Chan [Zak]  (CIS:71542,2712)
  994. *-- Date........: 01/05/1993
  995. *-- Notes.......: Quicken-style dates
  996. *                 Works best when BELL is OFF and CONFIRM is ON
  997. *                 Works with any SET DATE format
  998. *-- Written for.: dBASE IV, 1.5
  999. *-- Rev. History: 01/05/1993 1.0
  1000. *-- Calls.......: FDoM()               Function in DATES.PRG
  1001. *--               LDoM()               Function in DATES.PRG
  1002. *--               FDoY()               Function in DATES.PRG
  1003. *--               LDoY()               Function in DATES.PRG
  1004. *--               Strip()              Function in STRINGS.PRG
  1005. *-- Called by...: WHEN clause of GET
  1006. *-- Usage.......: @ ... GET <dArg> ... WHEN QDate( <dArg> ) ....
  1007. *--
  1008. *--                 Key         Function
  1009. *--                 ---         --------
  1010. *--                  T           Today's date
  1011. *--                  - or _      Day before
  1012. *--                  + or =      Day after
  1013. *--                  M           First day of month  |  Repeated keypress will
  1014. *--                  H           Last day of month   |  give you previous/next
  1015. *--                  Y           First day of year   |  month/year
  1016. *--                  R           Last day of year    |
  1017. *--                  digit       Begin manual date entry
  1018. *--
  1019. *-- Example.....: dFoo = date()
  1020. *--               @ 10,10 get dFoo when QDate( dFoo )
  1021. *-- Returns.....: .T.
  1022. *-- Parameters..: dArg = Date variable/field you're GETting
  1023. *-------------------------------------------------------------------------------
  1024.  
  1025.   parameter dArg
  1026.   private lLoop, nRow, nCol, lConfirmOn, nKey, cLastKey, cSimKey
  1027.   lLoop      = .t.
  1028.   nRow       = row()
  1029.   nCol       = col()
  1030.   lConfirmOn = ( set( "CONFIRM" ) = "ON" )
  1031.   cLastKey   = ""
  1032.   cSimKey    = ""
  1033.  
  1034.   *-- Save screen in case of Esc
  1035.   save screen to sQDate
  1036.  
  1037.   *-- Check for skip flag (used when SET CONFIRM is ON)
  1038.   if type( "x__QDate" ) # "U"
  1039.     release x__QDate
  1040.  
  1041.   else
  1042.     do while lLoop
  1043.       *-- Display current date in special color
  1044.       @ nRow, nCol say dArg color gb+/n        && <-- use your own color ...
  1045.       *-- Move cursor to beginning of date
  1046.       @ nRow, nCol say ""
  1047.       *-- Wait for a keypress
  1048.       nKey = inkey( 0 )
  1049.       *-- Convert to uppercase; ignore keys with negative INKEY() values
  1050.       cKey = upper( chr( max( nKey, 0 )))
  1051.  
  1052.       do case
  1053.         case cKey = "T"                 && Today
  1054.           dArg = date()
  1055.         case cKey = "-" .or. cKey = "_" && The day before
  1056.           dArg = dArg - 1
  1057.         case cKey = "+" .or. cKey = "=" && The day after
  1058.           dArg = dArg + 1
  1059.         case cKey = "M"                 && First day of the month
  1060.           dArg = FDoM( iif( cLastKey = "M", dArg - 1, dArg))
  1061.         case cKey = "H"                 && Last day of the month
  1062.           dArg = LDoM( iif( cLastKey = "H", dArg + 1, dArg))
  1063.         case cKey = "Y"                 && First day of the year
  1064.           dArg = FDoY( iif( cLastKey = "Y", dArg - 1, dArg))
  1065.         case cKey = "R"                 && Last day of the year
  1066.           dArg = LDoY( iif( cLastKey = "R", dArg + 1, dArg))
  1067.         case cKey $ "0123456789"        && Digit -- manual date entry
  1068.           lLoop = .f.
  1069.           *-- Clear entry and start at beginning
  1070.           keyboard chr( 25 ) + chr( 26 ) + cKey
  1071.         case nKey >= 32 .and. nKey < 127 .or. nKey > 127
  1072.           *-- Ignore invalid keys, like letters and symbols
  1073.         case nKey = 27 .or. nKey = 17   && Esc or Ctrl-Q
  1074.           lLoop = .f.
  1075.           *-- Restore screen and quit
  1076.           restore screen from sQDate
  1077.           keyboard cKey
  1078.         otherwise
  1079.           lLoop = .f.
  1080.           *-- Figure out how to simulate last keypress
  1081.           *-- If SET CONFIRM is OFF
  1082.           if .not. lConfirmOn
  1083.             *-- Go back up to date field
  1084.             cSimKey = "{UP}"              && Up arrow
  1085.             *-- Create flag variable to skip routine
  1086.             public x__QDate
  1087.           endif
  1088.           cSimKey = cSimKey + "{HOME}"
  1089.           *-- Recreate keypress
  1090.           do case
  1091.             case nKey = -400
  1092.               cSimKey = cSimKey + "{BACKTAB}"
  1093.             otherwise
  1094.               cSimKey = cSimKey + cKey
  1095.           endcase
  1096.           *-- Clear entry and "type in" date without separators
  1097.           *-- And simulate last keypress
  1098.           keyboard "{HOME}{CTRL-Y}" + ;
  1099.                    Strip( dtoc( dArg ), left( ltrim( dtoc( {} )), 1)) + cSimKey
  1100.       endcase
  1101.       *-- Save key just pressed
  1102.       cLastKey = cKey
  1103.  
  1104.     enddo
  1105.  
  1106.   endif
  1107.  
  1108.   *-- release the screen from memory before returning
  1109.   release screen sQDate
  1110.  
  1111. RETURN .t.
  1112. *-- EoF: QDate()
  1113.  
  1114. *--------------------------------------------------------------------------
  1115. *-- Strip() is here from STRINGS.PRG to make life a bit easier ...
  1116. *--------------------------------------------------------------------------
  1117.  
  1118. FUNCTION Strip
  1119. *-------------------------------------------------------------------------------
  1120. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  1121. *-- Date........: 01/05/1993
  1122. *-- Notes.......: Strips out specified character(s) from a string
  1123. *-- Written for.: dBASE IV, 1.5
  1124. *-- Rev. History: None
  1125. *-- Calls.......: None
  1126. *-- Called by...: Any
  1127. *-- Usage.......: Strip(<cVar>,<cArg>)
  1128. *-- Example.....: ?strip(dtoc(date(),"/")
  1129. *-- Returns.....: Character
  1130. *-- Parameters..: cVar = variable/field to remove character(s) from
  1131. *--               cArg = item to remove from cVar
  1132. *-------------------------------------------------------------------------------
  1133.  
  1134.   parameter cVar, cArg
  1135.   do while cArg $ cVar
  1136.     cVar = stuff( cVar, at( cArg, cVar ), 1, "" )
  1137.   enddo
  1138.  
  1139. RETURN cVar
  1140. *-- EoF: Strip()
  1141.  
  1142. *-------------------------------------------------------------------------------
  1143. *-- EoP: DATES.PRG
  1144. *-------------------------------------------------------------------------------
  1145.